home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / glisp / glisp.000 / GLISP.UNIX.TAR / closunix / closfunc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-04-03  |  13.9 KB  |  470 lines
  1. /*                 GRAPHIC LISP            */
  2. /*        Scritto nel 1991-94 da Zoia Andrea Michele     */
  3. /*        Via Pergola #1 Tirano (SO) Tel. 0342-704210    */
  4. /* file closfunc.c */
  5.  
  6. #include "clos.h"
  7.  
  8. void    print_s_expr();
  9. int     skip_spaces_tabs_nwl();
  10.  
  11. int    chw;
  12. char    sbuf[MAX_ID_LENGHT+1];
  13. FILE    *print_sx_fileout;
  14.  
  15.  
  16.  
  17.  
  18. void    eval LF_PARAMS
  19. {
  20.  /* la funzione eval ritorna SEMPRE un nodo FIX cioé un nodo che     */
  21.  /* verrà recuperato dal GC insieme a tutti i suoi legami         */
  22.  /* un nodo FIX risiede comunque nella lock_list e verrà,eventualmente,    */
  23.  /* successivamente rimosso con la funzione node_signal         */
  24.  /* Esempio (LIST (CONS 1 2) (GC) ) -> ( (1.2) T )            */
  25.  /* se il cons (1.2) non venisse FIX-ato il GC successivo lo distruggerebbe*/
  26.  /*                                    */
  27.  /* Gli environment locale (lenv) e speciale (genv) contengono i legami    */
  28.  /* dinamici dell'interprete                        */
  29.  /*                                    */
  30.  /* Il nodo nin é la s-espressione da valutare e deve essere un nodo FIX*/
  31.  /* o appartenere ad una lista con un CONS precedente FIX-ato        */
  32.  /*                                    */
  33.  /* NOTA: Questa condizione é assicurata SEMPRE(!!) dal fatto che una     */
  34.  /*  s-espressione da valutare può provenire da 2 parti:                */
  35.  /*  1) immessa da tastiera e dunque è sicuramente bloccata dato che    */
  36.  /*    é compsta da nodi appena allocati (si veda closyacc.y)        */
  37.  /*  2) prelevata da un risultato di EVAL e dato che il            */
  38.  /*    nodo ritornato da EVAL é sempre FIX ciò assicura sempre         */
  39.  /*    la condizione.                            */
  40.  /* Questa condizione assicura che quando si chiama una EVAL un'eventuale*/
  41.  /* GC non corrompe la lista di ingresso dato che é FIX o é attaccata ad un*/
  42.  /* CONS FIX. Casomai la valutazione modifichi proprio questa lista    */
  43.  /* con ad.es                                               */
  44.  /* (SETF list '(SETF (CDR list) nil), (EVAL list)                      */
  45.  /* (funzione AUTOMODIFICANTE abbastanza strana ... )            */
  46.  /* allora il reperimento del CDR FIX-a la lista ((CDR list) nil) che    */
  47.  /* non verrà comunque distrutta da un eventuale GC, il FIX-amento della*/
  48.  /* lista lo fa proprio EVAL alla fine. Cioé come ho detto all'inizio     */
  49.  /* EVAL ritorna proprio un nodo FIX.                    */
  50.  /* Le funzioni automodificanti sono abbastanza strane e generano spesso*/
  51.  /* risultati inattesi, non ho mai visto nessuno utilizzarle, ne tantomeno*/
  52.  /* le utilizzo io, comunque dal punto di vista teorico non devono confondere*/
  53.  /* l'interprete o fargli generare errori interni.            */
  54.  /*                                    */
  55.  /* DIFFERENZA TRA NODI LOCK e NODI FIX                    */
  56.  /* i nodi LOCK vengono recuperati DA SOLI dal GC            */
  57.  /* i nodi FIX vengono recuperati insieme alla loro sottolista.        */
  58.  /* es: ( 1 . 2 ) se il cons é FIX allora il GC recupera tutta la lista    */
  59.  /*   se il cons é LOCK allora il GC non recupera i numeri 1 e 2    */
  60.  
  61.  
  62.  unsigned long        magic=0x12345678L;
  63.  /* valore cercato dalla funzione stack_backtrace in modo da trovare sullo*/
  64.  /* stack tutte le chiamate alla eval e mostrarle all' utente in caso di*/
  65.  /* errore, é un metodo bruto e dipendente dal sistema infatti la funzione*/
  66.  /* stack_backtrace, che usa magic, non può essere Ansi-C        */
  67.  
  68.  REGISTER_MOD n_type    t=TYPE(nin);
  69.  
  70. #ifdef _Windows
  71.  /* rilascia la CPU a Windows dato che non é preemptivo */
  72.  if(SelfPreemptive){
  73.    WindowsReleaseCPU();
  74.  }
  75. #endif
  76.  
  77.  if(t&NT_IS_CONS){
  78.    /* il nodo nin é un cons: la parte sinistra é un nome?        */
  79.    if(IS_NAME(CONSLEFT(nin))){
  80.      nout->node=CONSLEFT(nin);
  81.    }else{
  82.      /* si valuta la sua parte sinistra per vedere            */
  83.      /* se é un simbolo atomico. NB: LAMBDA ritorna un simbolo atomico    */
  84.      /* anonimo con attaccata una funzione in modo da rendere uniforme    */
  85.      /* e semplice questa parte di codice.                */
  86.      eval(CONSLEFT(nin),nout,genv,lenv,EVAL_SETF);
  87.  
  88.      /* se si valuta ad.es (10 20) -> ERRORE 10 non é una funzione!    */
  89.      if(!IS_NAME(nout->node))
  90.        error(E_BADFUNC,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&nout->node);
  91.    }
  92.    /* se si valuta ad.es (A 20) -> ERRORE A non ha un legame funzionale    */
  93.    if(!HAS_FUNCTION(nout->node))
  94.      error(E_UNBOUNDFUNC,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&nout->node);
  95.  
  96.    /* si chiama la funzione                         */
  97.    apply_func(FUNCTION(nout->node),CONSRIGHT(nin),nout,genv,lenv,fl);
  98.  
  99.    /* apply_func blocca (FIX) il risultato nout                */
  100.    return;
  101.  
  102.  }
  103.  
  104.  if(t&NT_IS_NAME){
  105.    /* Se nin e'un simbolo atomico ad.es 'A'                 */
  106.  
  107.    /* 1) controlla se ha un valore globale                */
  108.    if(t&NT_HAS_VALUE){
  109.      nout->type=P_VALUE;
  110.      nout->node=nin;
  111.      node_lock(VALUE(nin));
  112.      return;
  113.    }
  114.  
  115.    /* 2) controlla se e' un nodo DEFVAR legame speciale libero        */
  116.    if(t&NT_HAS_BIND){
  117.      /* lo cerca nell'environment speciale                */
  118.      if(find_in_alist(nin,nout,genv)){
  119.        /* non lo ha trovato                         */
  120.        /* si prende il valore di default                 */
  121.        nout->type=P_VALUE;
  122.        nout->node=nin;
  123.        node_lock(VALUE(nin));
  124.        return;
  125.      }
  126.      /* lo ha trovato e lo blocca                     */
  127.      node_lock(CONSRIGHT(nout->node));
  128.      return;
  129.    }
  130.  
  131.    /* 3) é un legame locale                        */
  132.    /* controlla se e' in local environment e se lo trova: OK        */
  133.    if(!find_in_alist(nin,nout,lenv)){
  134.      /* lo ha trovato e lo blocca                    */
  135.      node_lock(CONSRIGHT(nout->node));
  136.      return;
  137.    }
  138.  
  139.    /* altrimenti se eval e' chiamata da setf                 */
  140.    /* ritorna il puntatore al valore globale (unbound) del nodo     */
  141.    if(fl==EVAL_SETF){
  142.      nout->type=P_UNBOUNDVALUE; /* solo per SetF */
  143.      nout->node=nin;
  144.      return;
  145.    }
  146.    error(E_UNBOUND,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&nin);
  147.  }
  148.  
  149.  /* se e'un nodo-valore ritorna tutto il nodo                 */
  150.  nout->type=P_ALLNODE;
  151.  nout->node=nin;
  152.  node_lock(nin);
  153.  return;
  154. }
  155.  
  156.  
  157. void apply_func(func,nin,nout,genv,lenv,fl)
  158. node func;
  159. node nin;
  160. node_p *nout;
  161. node genv;
  162. node lenv;
  163. unsigned fl;
  164. {
  165.  /* CAMPIONA LO STATO DI LOCK LIST, alla fine della valutazione lock-list*/
  166.  /* verrà riportata alle condizioni quì memorizzate            */
  167.  node remalloc=node_getlastlock();
  168.  
  169.  /* BLOCCA GLI ENVIRONMENT in modo che un eventuale GC valutando     */
  170.  /* una funzione non li distrugga                    */
  171.  node_lock(genv);
  172.  node_lock(lenv);
  173.  
  174.  /* BLOCCA la funzione corrente dato che potrebbe essere unbound-ata    */
  175.  /* al suo interno es: (defun R() (defun R() 'y) 'x)            */
  176.  /*         ""per curiosità"" la prima volta (r) torna X la seconda    */
  177.  /*          (e le successive) (r) tornano Y) alcuni interpreti quì    */
  178.  /*          falliscono miseramente.                */
  179.  node_lock(func);
  180.  
  181.  if(IS_TRACE(func)){
  182.    sprintf(buf1,"Calling function: %s\n",string_get(NAME(CONSLEFT(nin)),buf2));
  183.    lisp_print_string(buf1,stderr);
  184.    lisp_print_string("Parameter list:",stderr);
  185.    fprint_func(CONSRIGHT(nin),stderr);
  186.    lisp_print_string("\nLocal environment:",stderr);
  187.    fprint_func(lenv,stderr);
  188.    lisp_print_string("\nSpecial environment:",stderr);
  189.    fprint_func(genv,stderr);
  190.    lisp_print_string("\nHit a key\n",stderr);
  191.    cl_getch();
  192.  }
  193.  switch(GET_VTYPE(func)){
  194.    case NT_SYSFUNC:
  195.      (*SYSFUNC(func))(nin,nout,genv,lenv,fl);
  196.      break;
  197.    case NT_UFUNC:
  198.      lambda_eval(func,eval_list(nin,genv,lenv),nout,genv,lenv,fl);
  199.      break;
  200.    case NT_MACRO:
  201.      macro_eval(func,nin,nout,genv,lenv,fl);
  202.      break;
  203.    case NT_METHOD:
  204.      method_eval(METHOD(func),eval_list(nin,genv,lenv),nout,genv,lenv,fl);
  205.      break;
  206.    case NT_ACCESSOR:
  207.      accessor_eval(func,nin,nout,genv,lenv);
  208.      break;
  209.    default:
  210.      /* se si lega una non-funzione ad un legame funzionale        */
  211.      /* si finisce quì ....                         */
  212.      /* es: (SETF #'A 100) (A 12)                    */
  213.      error(E_BADFUNC,ERR_TBLVL|ERR_MERROR|ERR_PNODE,&func);
  214.  }
  215.  if(IS_TRACE(func)){
  216.    sprintf(buf1,"Function: %s has returned:",string_get(NAME(CONSLEFT(nin)),buf2));
  217.    lisp_print_string(buf1,stderr);
  218.    fprint_func(calc_pointer(nout),stderr);
  219.    lisp_print_string("\nHit a key\n",stderr);
  220.    cl_getch();
  221.  }
  222.  /* riporta lo stato della memoria al momento precedente alla chiamata    */
  223.  /* recuperando di fatto TUTTI i nodi allocati, LOCK-ati e FIX-ati    */
  224.  /* generati dalla funzione valutata                    */
  225.  node_signal(remalloc);
  226.  
  227.  /* però bisogna salvare il risultato                    */
  228.  /* si pensi a (LIST (CONS 1 2) (GC)) se il risultato di (CONS 1 2)    */
  229.  /* non é bloccato allora (GC) lo rimuove.                */
  230.  /* NB: si usa calc_pointer per bloccare il nodo effettivamente puntato    */
  231.  /*    da nout                                */
  232.  node_lock(nout->node);
  233.  
  234.  /* NB: calc_pointer non controlla i flags UNBOUND            */
  235.  if((nout->type&0xf0)!=0x30)
  236.    node_lock(calc_pointer(nout));
  237.  
  238.  /* si noti che, operando in questo modo, ovunque io chiami una eval    */
  239.  /* ho la sicurezza che tutti i legami visibili sono preservati        */
  240.  /* da un eventuale GC dato che si bloccano gli environment.        */
  241.  /* Inoltre il risultato ottenuto é automaticamente preservato        */
  242. }
  243.  
  244.  
  245. node eval_list(list,genv,lenv)
  246. node list;
  247. node genv;
  248. node lenv;
  249. {
  250.  /* genera una lista contenente tutti gli elementi di list valutati */
  251.  
  252.  node retlist=NIL;
  253.  node prev;
  254.  node_p nout;
  255.  
  256.  while(IS_CONS(list)){
  257.    eval(CONSLEFT(list),&nout,genv,lenv,EVAL_NORM);
  258.    if(retlist==NIL){
  259.      retlist=prev=node_make();
  260.    }else{
  261.      CONSRIGHT(prev)=node_make();
  262.      prev=CONSRIGHT(prev);
  263.    }
  264.    TYPE(prev)|=NT_IS_CONS;
  265.    CONSLEFT(prev)=calc_pointer(&nout);
  266.    CONSRIGHT(prev)=NIL;
  267.    list=CONSRIGHT(list);
  268.  }
  269.  return retlist;
  270. }
  271.  
  272.  
  273. /*=========== funzioni di stampa dei nodi ============================== */
  274.  
  275. /* stampa il nodo n sullo stream f senza appendere newline */
  276. node    fprint_func( n,f)
  277. node n;
  278. FILE *f;
  279. {
  280.  print_sx_fileout=f;
  281.  chw=0;
  282.  print_s_expr(n,1);
  283.  return n;
  284. }
  285.  
  286.  
  287. void print_s_expr( no, f)
  288. node no;
  289. int f;
  290. {
  291.  node n;
  292.  
  293.  if(chw>60){ chw=0;lisp_print_string("\n",print_sx_fileout); }
  294.  
  295.  switch(GET_NTYPE(no)){
  296.    case NT_IS_VALUE:
  297.      switch(GET_VTYPE(no)){
  298.        case NT_INTEGER:
  299.          sprintf(sbuf,"%ld",INTEGER(no));
  300.      lisp_print_string(sbuf,print_sx_fileout);
  301.      chw+=strlen(sbuf);
  302.      return;
  303.        case NT_REAL:
  304.      sprintf(sbuf,"%15.15lf",REAL(no));
  305.      lisp_print_string(sbuf,print_sx_fileout);
  306.      chw+=strlen(sbuf);
  307.      return;
  308.        case NT_RATIO:
  309.      sprintf(sbuf,"%ld/%ld",RATIO_NUM(no),RATIO_DEN(no));
  310.      lisp_print_string(sbuf,print_sx_fileout);
  311.      chw+=strlen(sbuf);
  312.      return;
  313.        case NT_STRING:
  314.      sprintf(sbuf,"\"%s\"",string_get(STRING(no),buf1));
  315.      lisp_print_string(sbuf,print_sx_fileout);
  316.      chw+=strlen(sbuf);
  317.      return;
  318.        case NT_CNAME:
  319.          sprintf(sbuf,":");
  320.      lisp_print_string(sbuf,print_sx_fileout);
  321.      chw+=1;
  322.          print_s_expr(CNAME(no),1);
  323.          return;
  324.        case NT_ENAME:
  325.          sprintf(sbuf,"&");
  326.          lisp_print_string(sbuf,print_sx_fileout);
  327.          chw+=1;
  328.      print_s_expr(ENAME(no),1);
  329.      return;
  330.        case NT_METHOD:
  331.          sprintf(sbuf,"#<Method funcs:%ld>",(long)listlen_func(METHOD(no)));
  332.      lisp_print_string(sbuf,print_sx_fileout);
  333.          chw+=strlen(sbuf);
  334.          return;
  335.        case NT_CLASS:
  336.          sprintf(sbuf,"#<Class :");
  337.          lisp_print_string(sbuf,print_sx_fileout);
  338.          chw+=strlen(sbuf);
  339.          print_s_expr(CLASS_INSTANCE(no),1);
  340.          lisp_print_string(">",print_sx_fileout);
  341.      chw++;
  342.          return;
  343.        case NT_SYSFUNC:
  344.      sprintf(sbuf,"#<SysFunc %p>",SYSFUNC(no));
  345.          lisp_print_string(sbuf,print_sx_fileout);
  346.          chw+=strlen(sbuf);
  347.      return;
  348.        case NT_STREAM:
  349.      sprintf(sbuf,"#<Stream %p>",STREAM(no));
  350.      lisp_print_string(sbuf,print_sx_fileout);
  351.      chw+=strlen(sbuf);
  352.      return;
  353.        case NT_ACCESSOR:
  354.          sprintf(sbuf,"#<Accessor of class %s field %ld>",
  355.            string_get(NAME(ACCESSOR_NAME(no)),buf1),ACCESSOR_FIELD(no));
  356.          lisp_print_string(sbuf,print_sx_fileout);
  357.          chw+=strlen(sbuf);
  358.          return;
  359.        case NT_CHAR:
  360.          sprintf(sbuf,"#\\%c",CHARACTER(no));
  361.      lisp_print_string(sbuf,print_sx_fileout);
  362.          chw+=strlen(sbuf);
  363.      return;
  364.        case NT_MACRO:
  365.      sprintf(sbuf,"#<Macro Lexical Closure par:");
  366.      lisp_print_string(sbuf,print_sx_fileout);
  367.      chw+=25;
  368.      goto PrintUfunc;
  369.        case NT_UFUNC:
  370.      sprintf(sbuf,"#<Lexical Closure par:");
  371.      lisp_print_string(sbuf,print_sx_fileout);
  372.      chw+=19;
  373.      PrintUfunc:
  374.      print_s_expr(UFUNC_PAR(no),1);
  375.  
  376.      sprintf(sbuf," type:");
  377.      lisp_print_string(sbuf,print_sx_fileout);
  378.      chw+=6;
  379.      print_s_expr(UFUNC_TYPE(no),1);
  380.  
  381.          sprintf(sbuf," opt:");
  382.          lisp_print_string(sbuf,print_sx_fileout);
  383.          chw+=5;
  384.          print_s_expr(UFUNC_OPT(no),1);
  385.  
  386.          sprintf(sbuf," rest:");
  387.      lisp_print_string(sbuf,print_sx_fileout);
  388.          chw+=6;
  389.          print_s_expr(UFUNC_REST(no),1);
  390.  
  391.          sprintf(sbuf," key:");
  392.      lisp_print_string(sbuf,print_sx_fileout);
  393.          chw+=5;
  394.          print_s_expr(UFUNC_KEY(no),1);
  395.  
  396.      sprintf(sbuf," aux:");
  397.      lisp_print_string(sbuf,print_sx_fileout);
  398.          chw+=5;
  399.      print_s_expr(UFUNC_AUX(no),1);
  400.  
  401.          sprintf(sbuf," sex:");
  402.          lisp_print_string(sbuf,print_sx_fileout);
  403.          chw+=5;
  404.          print_s_expr(UFUNC_SEX(no),1);
  405.  
  406.          sprintf(sbuf," env:");
  407.      lisp_print_string(sbuf,print_sx_fileout);
  408.      chw+=5;
  409.          print_s_expr(UFUNC_ENV(no),1);
  410.  
  411.          sprintf(sbuf,">");
  412.      lisp_print_string(sbuf,print_sx_fileout);
  413.          chw+=1;
  414.          return;
  415.  
  416.        default:
  417.          error(E_PRINT_BAD1,ERR_MINTERNAL|ERR_TNORM|ERR_PVOID,NULL);
  418.          return;
  419.      }
  420.    case NT_IS_CONS:
  421.      if(f){
  422.        sprintf(sbuf,"(");
  423.        lisp_print_string(sbuf,print_sx_fileout);
  424.        chw+=1;
  425.      }
  426.      print_s_expr(CONSLEFT(no),1);
  427.      if((n=CONSRIGHT(no))==NIL){
  428.        sprintf(sbuf,")");
  429.        lisp_print_string(sbuf,print_sx_fileout);
  430.        chw+=1;
  431.        return;
  432.      }
  433.      if(IS_CONS(n)){
  434.        sprintf(sbuf," ");chw+=1;
  435.        lisp_print_string(sbuf,print_sx_fileout);
  436.        print_s_expr(n,0);
  437.        return;
  438.      }
  439.      sprintf(sbuf," . ");chw+=3;
  440.      lisp_print_string(sbuf,print_sx_fileout);
  441.      print_s_expr(n,1);
  442.      sprintf(sbuf,")");chw+=1;
  443.      lisp_print_string(sbuf,print_sx_fileout);
  444.      return;
  445.  
  446.    case NT_IS_NAME:
  447.      if(HAS_NAME(no)){
  448. #ifdef LISPMEM_DEBUG
  449.     sprintf(sbuf,"%s{this %p hash %lu next %p}"
  450.       ,string_get(NAME(no),buf1),(node_s*)no,HASH(no),NEXT(no));
  451. #else
  452.     sprintf(sbuf,"%s",string_get(NAME(no),buf1));
  453.     chw+=strlen(sbuf);
  454. #endif
  455.        lisp_print_string(sbuf,print_sx_fileout);
  456.        return;
  457.      }
  458.      sprintf(sbuf,"#<anonymous node %p>",P(no));
  459.      lisp_print_string(sbuf,print_sx_fileout);
  460.      return;
  461.    default:
  462.      error(E_PRINT_BAD2,ERR_MINTERNAL|ERR_TNORM|ERR_PVOID,NULL);
  463.      return;
  464.  }
  465. }
  466.  
  467.  
  468.  
  469.  
  470.